perm filename TREE.PAS[S1,ALS] blob sn#337865 filedate 1978-10-20 generic text, type T, neo UTF8
(*$A+,B-*)
PROGRAM TREESORT(OUTPUT);

(**********************************************************************)

CONST

MAXINDX=	8000;

TYPE

SORTINDX=	1 .. MAXINDX;
SORTITEM=	INTEGER;
SORTARY=	ARRAY [SORTINDX] OF SORTITEM;

VAR

A:		SORTARY;

(**********************************************************************)
(*
PROCEDURE WRTINT(I, LEN: INTEGER);

VAR
POW10:	INTEGER;
NEG:	BOOLEAN;
DIGS:	INTEGER;
TMP:	INTEGER;
I:	INTEGER;
LEN:	INTEGER;

BEGIN

  NEG:=FALSE;
  IF I<0 THEN BEGIN
    LEN:=LEN-1;
    NEG:=TRUE;
    I:=-I;
  END;

  DIGS:=0;
  TMP:=I;
  POW10:=1;
  REPEAT
    TMP:=TMP DIV 10;
    POW10:=POW10*10;
    DIGS:=DIGS+1;
  UNTIL TMP=0;

  FOR TMP:=LEN DOWNTO DIGS DO BEGIN
    CHAROUT(' ');
  END;

  IF NEG THEN BEGIN
    CHAROUT('-');
  END;
  
  REPEAT
    POW10:=POW10 DIV 10;
    TMP:=I DIV POW10;
    CHAROUT(CHR(TMP+ORD('0')));
    I:=I MOD POW10;
  UNTIL POW10=1;

END;
)*
(**********************************************************************)

PROCEDURE INITARY(VAR ARY: SORTARY);

CONST
A=	54321;
C=	0;
M=	59999;

VAR
I:	SORTINDX;
RAND:	INTEGER;

BEGIN

RAND:=12345;
FOR I:=1 TO MAXINDX DO BEGIN
  RAND:=((A*RAND+C) MOD M);
  ARY[I]:=RAND;
END;
  
END;

(**********************************************************************)
(*
PROCEDURE PRTARY(VAR A: SORTARY);

VAR
I:	SORTINDX;

BEGIN

FOR I:=1 TO MAXINDX DO BEGIN
  WRTINT(A[I],12);
  WRITELN(OUTPUT);
END;
WRITELN(OUTPUT);

END;
)*
(**********************************************************************)

PROCEDURE SORT(VAR A: SORTARY);

LABEL	1,2;

VAR
I,
K:	SORTINDX;
J:	INTEGER;
T:	SORTITEM;

BEGIN

FOR I:=2 TO MAXINDX DO BEGIN
  K:=I;
  J:=I;
  T:=A[I];

  REPEAT
    J:=J DIV 2;
    IF T<=A[J] THEN GOTO 1;
    A[K]:=A[J];
    K:=J;
  UNTIL J=1;

  1:
  A[K]:=T;
END;

FOR I:=MAXINDX-1 DOWNTO 1 DO BEGIN
  T:=A[I+1];
  A[I+1]:=A[1];
  K:=1;
  J:=2;
  WHILE J<=I DO BEGIN
    IF J<I THEN IF (A[J+1]>A[J]) THEN J:=J+1;
    IF A[J]>T THEN BEGIN
      A[K]:=A[J];
      K:=J;
      J:=2*J;
    END ELSE GOTO 2;
  END;

  2:
  A[K]:=T;
END;

END;

(**********************************************************************)

BEGIN

INITARY(A);
(*PRTARY(A);*)
SORT(A);
(*PRTARY(A);*)

END.

(**********************************************************************)